home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / float-tran.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  9.1 KB  |  292 lines
  1. ;;; -*- Mode: Lisp; Package: C; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: float-tran.lisp,v 1.14 92/08/13 18:03:59 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains floating-point specific transforms, and may be somewhat
  15. ;;; implementation dependent in its assumptions of what the formats are.
  16. ;;;
  17. ;;; Author: Rob MacLachlan
  18. ;;; 
  19. (in-package "C")
  20.  
  21.  
  22. ;;;; Coercions:
  23.  
  24. #-new-compiler
  25. (progn
  26.   (defun %single-float (x) (coerce x 'single-float))
  27.   (defun %double-float (x) (coerce x 'double-float)))
  28.  
  29. (defknown %single-float (real) single-float (movable foldable flushable))
  30. (defknown %double-float (real) double-float (movable foldable flushable))
  31.  
  32. (deftransform float ((n &optional f) (* &optional single-float))
  33.   '(%single-float n))
  34.  
  35. (deftransform float ((n f) (* double-float))
  36.   '(%double-float n))
  37.  
  38. (deftransform %single-float ((n) (single-float))
  39.   'n)
  40.  
  41. (deftransform %double-float ((n) (double-float))
  42.   'n)
  43.  
  44. (deftransform coerce ((n type)
  45.               (* (constant-argument
  46.               (member float short-float single-float))))
  47.   '(%single-float n))
  48.  
  49. (deftransform coerce ((n type)
  50.               (* (constant-argument
  51.               (member double-float long-float))))
  52.   '(%double-float n))
  53.  
  54. ;;; Not strictly float functions, but primarily useful on floats:
  55. ;;;
  56. (macrolet ((frob (fun ufun)
  57.          `(progn
  58.         (defknown ,ufun (real) integer (movable foldable flushable))
  59.         (deftransform ,fun ((x &optional by)
  60.                     (* &optional
  61.                        (constant-argument (member 1))))
  62.           '(let ((res (,ufun x)))
  63.              (values res (- x res)))))))
  64.   (frob truncate %unary-truncate)
  65.   (frob round %unary-round))
  66.  
  67.  
  68. ;;;; Float accessors:
  69.  
  70. (defknown make-single-float ((signed-byte 32)) single-float
  71.   (movable foldable flushable))
  72.  
  73. (defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float
  74.   (movable foldable flushable))
  75.  
  76. (defknown single-float-bits (single-float) (signed-byte 32)
  77.   (movable foldable flushable))
  78.  
  79. (defknown double-float-high-bits (double-float) (signed-byte 32)
  80.   (movable foldable flushable))
  81.  
  82. (defknown double-float-low-bits (double-float) (unsigned-byte 32)
  83.   (movable foldable flushable))
  84.  
  85.  
  86. (defun make-single-float (x) (make-single-float x))
  87. (defun make-double-float (hi lo) (make-double-float hi lo))
  88. (defun single-float-bits (x) (single-float-bits x))
  89. (defun double-float-high-bits (x) (double-float-high-bits x))
  90. (defun double-float-low-bits (x) (double-float-low-bits x))
  91.  
  92. (def-source-transform float-sign (float1 &optional (float2 nil f2-p))
  93.   (let ((n-f1 (gensym)))
  94.     (if f2-p
  95.     `(* (float-sign ,float1) (abs ,float2))
  96.     `(let ((,n-f1 ,float1))
  97.        (declare (float ,n-f1))
  98.        (if (minusp (if (typep ,n-f1 'single-float)
  99.                (single-float-bits ,n-f1)
  100.                (double-float-high-bits ,n-f1)))
  101.            (float -1 ,n-f1)
  102.            (float 1 ,n-f1))))))
  103.  
  104.  
  105. ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT:
  106. ;;;
  107. ;;;    Convert these operations to format specific versions when the format is
  108. ;;; known.
  109. ;;;
  110.  
  111. (deftype single-float-exponent ()
  112.   `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
  113.         vm:single-float-digits)
  114.         ,(- vm:single-float-normal-exponent-max vm:single-float-bias)))
  115.  
  116. (deftype double-float-exponent ()
  117.   `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
  118.         vm:double-float-digits)
  119.         ,(- vm:double-float-normal-exponent-max vm:double-float-bias)))
  120.  
  121.  
  122. (deftype single-float-int-exponent ()
  123.   `(integer ,(- vm:single-float-normal-exponent-min vm:single-float-bias
  124.         (* vm:single-float-digits 2))
  125.         ,(- vm:single-float-normal-exponent-max vm:single-float-bias
  126.         vm:single-float-digits)))
  127.  
  128. (deftype double-float-int-exponent ()
  129.   `(integer ,(- vm:double-float-normal-exponent-min vm:double-float-bias
  130.         (* vm:double-float-digits 2))
  131.         ,(- vm:double-float-normal-exponent-max vm:double-float-bias
  132.         vm:double-float-digits)))
  133.  
  134. (deftype single-float-significand ()
  135.   `(integer 0 (,(ash 1 vm:single-float-digits))))
  136.  
  137. (deftype double-float-significand ()
  138.   `(integer 0 (,(ash 1 vm:double-float-digits))))
  139.  
  140. (defknown decode-single-float (single-float)
  141.   (values single-float single-float-exponent (single-float -1f0 1f0))
  142.   (movable foldable flushable))
  143.  
  144. (defknown decode-double-float (double-float)
  145.   (values double-float double-float-exponent (double-float -1d0 1d0))
  146.   (movable foldable flushable))
  147.  
  148. (defknown integer-decode-single-float (single-float)
  149.   (values single-float-significand single-float-int-exponent (integer -1 1))
  150.   (movable foldable flushable))
  151.  
  152. (defknown integer-decode-double-float (double-float)
  153.   (values double-float-significand double-float-int-exponent (integer -1 1))
  154.   (movable foldable flushable)))
  155.  
  156. (defknown scale-single-float (single-float fixnum) single-float
  157.   (movable foldable flushable))
  158.  
  159. (defknown scale-double-float (double-float fixnum) double-float
  160.   (movable foldable flushable))
  161.  
  162. (deftransform decode-float ((x) (single-float))
  163.   '(decode-single-float x))
  164.  
  165. (deftransform decode-float ((x) (double-float))
  166.   '(decode-double-float x))
  167.  
  168. (deftransform integer-decode-float ((x) (single-float))
  169.   '(integer-decode-single-float x))
  170.  
  171. (deftransform integer-decode-float ((x) (double-float))
  172.   '(integer-decode-double-float x))
  173.  
  174. (deftransform scale-float ((f ex) (single-float *))
  175.   '(scale-single-float f ex))
  176.  
  177. (deftransform scale-float ((f ex) (double-float *))
  178.   '(scale-double-float f ex))
  179.  
  180.  
  181. ;;;; Float contagion:
  182.  
  183. ;;; FLOAT-CONTAGION-ARG1, ARG2  --  Internal
  184. ;;;
  185. ;;;    Do some stuff to recognize when the luser is doing mixed float and
  186. ;;; rational arithmetic, or different float types, and fix it up.  If we don't,
  187. ;;; he won't even get so much as an efficency note.
  188. ;;;
  189. (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
  190.   `(,(continuation-function-name (basic-combination-fun node))
  191.     (float x y) y))
  192. ;;;
  193. (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
  194.   `(,(continuation-function-name (basic-combination-fun node))
  195.     x (float y x)))
  196.  
  197. (dolist (x '(+ * / -))
  198.   (%deftransform x '(function (rational float) *) #'float-contagion-arg1)
  199.   (%deftransform x '(function (float rational) *) #'float-contagion-arg2))
  200.  
  201. (dolist (x '(= < > + * / -))
  202.   (%deftransform x '(function (single-float double-float) *)
  203.          #'float-contagion-arg1)
  204.   (%deftransform x '(function (double-float single-float) *)
  205.          #'float-contagion-arg2))
  206.  
  207.  
  208. ;;; Prevent zerop, plusp, minusp from losing horribly.  We can't in general
  209. ;;; float rational args to comparison, since Common Lisp semantics says we are
  210. ;;; supposed to compare as rationals, but we can do it for any rational that
  211. ;;; has a precise representation as a float (such as 0).
  212. ;;;
  213. (macrolet ((frob (op)
  214.          `(deftransform ,op ((x y) (float rational))
  215.         (unless (constant-continuation-p y)
  216.           (give-up "Can't open-code float to rational comparison."))
  217.         (let ((val (continuation-value y)))
  218.           (unless (eql (rational (float val)) val)
  219.             (give-up "~S doesn't have a precise float representation."
  220.                  val)))
  221.         `(,',op x (float y x)))))
  222.   (frob <)
  223.   (frob >)
  224.   (frob =))
  225.  
  226.  
  227. ;;;; Irrational derive-type methods:
  228.  
  229. ;;; Derive the result to be float for argument types in the appropriate domain.
  230. ;;;
  231. (dolist (stuff '((asin (real (-1.0) (1.0)))
  232.          (acos (real (-1.0) (1.0)))
  233.          (acosh (real 1.0))
  234.          (atanh (real (-1.0) (1.0)))
  235.          (sqrt (real 0.0))))
  236.   (destructuring-bind (name type) stuff
  237.     (let ((type (specifier-type type)))
  238.       (setf (function-info-derive-type (function-info-or-lose name))
  239.         #'(lambda (call)
  240.         (declare (type combination call))
  241.         (when (csubtypep (continuation-type
  242.                   (first (combination-args call)))
  243.                  type)
  244.           (specifier-type 'float)))))))
  245.  
  246.  
  247. ;;;; Irrational transforms:
  248.  
  249. (defknown (%sin %cos %tan %asin %acos %atan %sinh %cosh %tanh %asinh
  250.         %acosh %atanh %exp %expm1 %log %log10 %log1p %cbrt %sqrt)
  251.       (double-float) double-float
  252.   (movable foldable flushable))
  253.  
  254. (defknown (%atan2 %pow %hypot)
  255.       (double-float double-float) double-float
  256.   (movable foldable flushable))
  257.  
  258. (dolist (stuff '((exp %exp *)
  259.          (log %log float)
  260.          (sqrt %sqrt float)
  261.          (sin %sin *)
  262.          (cos %cos *)
  263.          (tan %tan *)
  264.          (asin %asin float)
  265.          (acos %acos float)
  266.          (atan %atan *)
  267.          (sinh %sinh *)
  268.          (cosh %cosh *)
  269.          (tanh %tanh *)
  270.          (asinh %asinh *)
  271.          (acosh %acosh float)
  272.          (atanh %atanh float)))
  273.   (destructuring-bind (name prim rtype) stuff
  274.     (deftransform name ((x) '(single-float) rtype :eval-name t)
  275.       `(coerce (,prim (coerce x 'double-float)) 'single-float))
  276.     (deftransform name ((x) '(double-float) rtype :eval-name t)
  277.       `(,prim x))))
  278.  
  279. (dolist (stuff '((expt %pow t)
  280.          (atan %atan2 t)))
  281.   (destructuring-bind (name prim rtype) stuff
  282.     (deftransform name ((x y) '(single-float) rtype :eval-name t)
  283.       `(coerce (,prim (coerce x 'double-float)
  284.               (coerce y 'double-float))
  285.            'single-float))
  286.     (deftransform name ((x y) '(double-float) rtype :eval-name t)
  287.       `(,prim x y))))
  288.  
  289. (deftransform log ((x y) (float float) float)
  290.   '(/ (log x) (log y)))
  291.  
  292.